home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0031_Another STARS.pas < prev    next >
Pascal/Delphi Source File  |  1993-10-28  |  4KB  |  136 lines
  1. {===========================================================================
  2.  BBS: Canada Remote Systems
  3. Date: 10-17-93 (23:26)
  4. From: BAS VAN GAALEN
  5. Subj: Stars?
  6.  
  7. {$N+}
  8.  
  9. program _Rotation;
  10.  
  11. uses
  12.   crt,dos;
  13.  
  14. const
  15.   NofPoints = 75;
  16.   Speed = 5;
  17.   Xc : real = 0;
  18.   Yc : real = 0;
  19.   Zc : real = 150;
  20.   SinTab : array[0..255] of integer = (
  21.     0,2,5,7,10,12,15,17,20,22,24,27,29,31,34,36,38,41,43,45,47,49,52,54,
  22.     56,58,60,62,64,66,67,69,71,73,74,76,78,79,81,82,83,85,86,87,88,90,91,
  23.     92,93,93,94,95,96,97,97,98,98,99,99,99,100,100,100,100,100,100,100,
  24.     100,99,99,99,98,98,97,97,96,95,95,94,93,92,91,90,89,88,87,85,84,83,
  25.     81,80,78,77,75,73,72,70,68,66,65,63,61,59,57,55,53,51,48,46,44,42,40,
  26.     37,35,33,30,28,26,23,21,18,16,14,11,9,6,4,1,-1,-4,-6,-9,-11,-14,-16,
  27.     -18,-21,-23,-26,-28,-30,-33,-35,-37,-40,-42,-44,-46,-48,-51,-53,-55,
  28.     -57,-59,-61,-63,-65,-66,-68,-70,-72,-73,-75,-77,-78,-80,-81,-83,-84,
  29.     -85,-87,-88,-89,-90,-91,-92,-93,-94,-95,-95,-96,-97,-97,-98,-98,-99,
  30.     -99,-99,-100,-100,-100,-100,-100,-100,-100,-100,-99,-99,-99,-98,-98,
  31.     -97,-97,-96,-95,-94,-93,-93,-92,-91,-90,-88,-87,-86,-85,-83,-82,-81,
  32.     -79,-78,-76,-74,-73,-71,-69,-67,-66,-64,-62,-60,-58,-56,-54,-52,-49,
  33.     -47,-45,-43,-41,-38,-36,-34,-31,-29,-27,-24,-22,-20,-17,-15,-12,-10,
  34.     -7,-5,-2,0);
  35.  
  36. type
  37.   PointRec = record
  38.                X,Y,Z : integer;
  39.              end;
  40.   PointPos = array[0..NofPoints] of PointRec;
  41.  
  42. var
  43.   Point : PointPos;
  44.  
  45. {----------------------------------------------------------------------------}
  46.  
  47. procedure SetGraphics(Mode : byte); assembler;
  48. asm mov AH,0; mov AL,Mode; int 10h; end;
  49.  
  50. {----------------------------------------------------------------------------}
  51.  
  52. procedure Init;
  53.  
  54. var
  55.   I : byte;
  56.  
  57. begin
  58.   randomize;
  59.   for I := 0 to NofPoints do begin
  60.     Point[I].X := random(250)-125;
  61.     Point[I].Y := random(250)-125;
  62.     Point[I].Z := random(250)-125;
  63.   end;
  64. end;
  65.  
  66. {----------------------------------------------------------------------------}
  67.  
  68. procedure DoRotation;
  69.  
  70. const
  71.   Xstep = 1;
  72.   Ystep = 1;
  73.   Zstep = -2;
  74.  
  75. var
  76.   Xp,Yp : array[0..NofPoints] of word;
  77.   X,Y,Z,X1,Y1,Z1 : real;
  78.   PhiX,PhiY,PhiZ : byte;
  79.   I,Color : byte;
  80.  
  81. function Sinus(Idx : byte) : real;
  82.  
  83. begin
  84.   Sinus := SinTab[Idx]/100;
  85. end;
  86.  
  87. function Cosinus(Idx : byte) : real;
  88.  
  89. begin
  90.   Cosinus := SinTab[(Idx+192) mod 255]/100;
  91. end;
  92.  
  93. begin
  94.   PhiX := 0; PhiY := 0; PhiZ := 0;
  95.   repeat
  96.     while (port[$3da] and 8) <> 8 do;
  97.     while (port[$3da] and 8) = 8 do;
  98.     for I := 0 to NofPoints do begin
  99.  
  100.       if (Xp[I]+160 < 320) and (Yp[I]+100 < 200) then
  101.         mem[$a000:(Yp[I]+100)*320+Xp[I]+160] := 0;
  102.  
  103.       X1 := Cosinus(PhiY)*Point[I].X-Sinus(PhiY)*Point[I].Z;
  104.       Z1 := Sinus(PhiY)*Point[I].X+Cosinus(PhiY)*Point[I].Z;
  105.       X := Cosinus(PhiZ)*X1+Sinus(PhiZ)*Point[I].Y;
  106.       Y1 := Cosinus(PhiZ)*Point[I].Y-Sinus(PhiZ)*X1;
  107.       Z := Cosinus(PhiX)*Z1-Sinus(PhiX)*Y1;
  108.       Y := Sinus(PhiX)*Z1+Cosinus(PhiX)*Y1;
  109.  
  110.       Xp[I] := round((Xc*Z-X*Zc)/(Z-Zc));
  111.       Yp[I] := round((Yc*Z-Y*Zc)/(Z-Zc));
  112.       if (Xp[I]+160 < 320) and (Yp[I]+100 < 200) then begin
  113.         Color := 31+round(Z/7);
  114.         if Color > 31 then Color := 31
  115.         else if Color < 16 then Color := 16;
  116.         mem[$a000:(Yp[I]+100)*320+Xp[I]+160] := Color;
  117.       end;
  118.  
  119.       inc(Point[I].Z,Speed); if Point[I].Z > 125 then Point[I].Z := -125;
  120.     end;
  121.     inc(PhiX,Xstep);
  122.     inc(PhiY,Ystep);
  123.     inc(PhiZ,Zstep);
  124.   until keypressed;
  125. end;
  126.  
  127. {----------------------------------------------------------------------------}
  128.  
  129. begin
  130.   SetGraphics($13);
  131.   Init;
  132.   DoRotation;
  133.   textmode(lastmode);
  134. end.
  135.  
  136.